home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clx.lha / clx / translate.l < prev   
Lisp/Scheme  |  1988-09-12  |  26KB  |  626 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:YES -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. (in-package 'xlib :use '(lisp))
  20.  
  21. (export '(define-keysym-set
  22.       keysym-set
  23.       define-keysym
  24.       undefine-keysym
  25.       default-keysym-translate
  26.       keysym
  27.       character->keysyms
  28.       keycode->keysym 
  29.       keysym->character
  30.       default-keysym-index
  31.       keycode->character
  32.       state-keysym-p
  33.       mapping-notify
  34.       keysym-in-map-p
  35.       character-in-map-p
  36.       keysym->keycodes
  37.       ))
  38.  
  39. (defvar *keysym-sets* nil) ;; Alist of (name first-keysym last-keysym)
  40.  
  41. (defun define-keysym-set (set first-keysym last-keysym)
  42.   ;; Define all keysyms from first-keysym up to and including
  43.   ;; last-keysym to be in SET (returned from the keysym-set function).
  44.   ;; Signals an error if the keysym range overlaps an existing set.
  45.  (declare (type keyword set)
  46.       (type keysym first-keysym last-keysym))
  47.   (when (> first-keysym last-keysym)
  48.     (rotatef first-keysym last-keysym))
  49.   (setq *keysym-sets* (delete set *keysym-sets* :key #'car))
  50.   (dolist (set *keysym-sets*)
  51.     (let ((first (second set))
  52.       (last (third set)))
  53.       (when (or (<= first first-keysym last)
  54.         (<= first last-keysym last))
  55.     (error "Keysym range overlaps existing set ~s" set))))
  56.   (push (list set first-keysym last-keysym) *keysym-sets*)
  57.   set)
  58.  
  59. (defun keysym-set (keysym)
  60.   ;; Return the character code set name of keysym
  61.   (declare (type keysym keysym)
  62.        (values keyword))
  63.   (dolist (set *keysym-sets*)
  64.     (let ((first (second set))
  65.       (last (third set)))
  66.       (when (<= first keysym last)
  67.     (return (first set))))))
  68.  
  69. (eval-when (compile eval load) ;; Required for Vaxlisp ...
  70. (defmacro keysym (keysym &rest bytes)
  71.   ;; Build a keysym.
  72.   ;; If KEYSYM is an integer, it is used as the most significant bits of
  73.   ;; the keysym, and BYTES are used to specify low order bytes. The last
  74.   ;; parameter is always byte4 of the keysym.  If KEYSYM is not an
  75.   ;; integer, the keysym associated with KEYSYM is returned.
  76.   ;;
  77.   ;; This is a macro and not a function macro to promote compile-time
  78.   ;; lookup. All arguments are evaluated.
  79.   (declare (type t keysym)
  80.        (type list bytes)
  81.        (values keysym))
  82.   (typecase keysym
  83.     ((integer 0)
  84.      (dolist (b bytes keysym) (setq keysym (+ (ash keysym 8) b))))
  85.     (otherwise
  86.      (or (car (character->keysyms keysym))
  87.      (error "~s Isn't the name of a keysym" keysym)))))
  88. )
  89.  
  90. (defvar *keysym->character-map* (make-hash-table :test #'eq :size 400))
  91.  
  92. ;; Keysym-mappings are a list of the form (object translate lowercase modifiers mask)
  93. ;; With the following accessor macros. Everything after OBJECT is optional.
  94.  
  95. (eval-when (eval compile) ;; Not needed at run-time
  96.  
  97. (defmacro keysym-mapping-object (keysym-mapping)
  98.   ;; Parameter to translate
  99.   `(first ,keysym-mapping))
  100.  
  101. (defmacro keysym-mapping-translate (keysym-mapping)
  102.   ;; Function to be called with parameters (display state OBJECT)
  103.   ;; when translating KEYSYM and modifiers and mask are satisfied.
  104.   `(second ,keysym-mapping))
  105.  
  106. (defmacro keysym-mapping-lowercase (keysym-mapping)
  107.   ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
  108.   ;; is the associated lowercase keysym.
  109.   `(third ,keysym-mapping))
  110.  
  111. (defmacro keysym-mapping-modifiers (keysym-mapping)
  112.   ;; MODIFIERS is either a modifier-mask or list containing intermixed
  113.   ;; keysyms and state-mask-keys specifying when to use this
  114.   ;; keysym-translation.
  115.   `(fourth ,keysym-mapping))
  116.  
  117. (defmacro keysym-mapping-mask (keysym-mapping)
  118.   ;; MASK is either a modifier-mask or list containing intermixed
  119.   ;; keysyms and state-mask-keys specifying which modifiers to look at
  120.   ;; (i.e.  modifiers not specified are don't-cares)
  121.   `(fifth ,keysym-mapping))
  122.  
  123. ) ;; end eval-when
  124.  
  125. (defvar *default-keysym-translate-mask*
  126.     (the (or (member :modifiers) mask16 list)    ; (list (or keysym state-mask-key))
  127.          (logand #xff (lognot (make-state-mask :lock))))
  128.   "Default keysym state mask to use during keysym-translation.")
  129.  
  130. (defun define-keysym (object keysym &key lowercase translate modifiers mask display)                  
  131.   ;; Define the translation from keysym/modifiers to a (usually
  132.   ;; character) object.  ANy previous keysym definition with
  133.   ;; KEYSYM and MODIFIERS is deleted before adding the new definition.
  134.   ;;
  135.   ;; MODIFIERS is either a modifier-mask or list containing intermixed
  136.   ;; keysyms and state-mask-keys specifying when to use this
  137.   ;; keysym-translation.  The default is NIL.
  138.   ;;
  139.   ;; MASK is either a modifier-mask or list containing intermixed
  140.   ;; keysyms and state-mask-keys specifying which modifiers to look at
  141.   ;; (i.e.  modifiers not specified are don't-cares).
  142.   ;; If mask is :MODIFIERS then the mask is the same as the modifiers
  143.   ;; (i.e.  modifiers not specified by modifiers are don't cares)
  144.   ;; The default mask is *default-keysym-translate-mask*
  145.   ;;
  146.   ;; If DISPLAY is specified, the translation will be local to DISPLAY,
  147.   ;; otherwise it will be the default translation for all displays.
  148.   ;;
  149.   ;; LOWERCASE is used for uppercase alphabetic keysyms.  The value
  150.   ;; is the associated lowercase keysym.  This information is used
  151.   ;; by the keysym-both-case-p predicate (for caps-lock computations)
  152.   ;; and by the keysym-downcase function.
  153.   ;;
  154.   ;; TRANSLATE will be called with parameters (display state OBJECT)
  155.   ;; when translating KEYSYM and modifiers and mask are satisfied.
  156.   ;; [e.g (zerop (logxor (logand state (or mask *default-keysym-translate-mask*))
  157.   ;;                     (or modifiers 0)))
  158.   ;;      when mask and modifiers aren't lists of keysyms]
  159.   ;; The default is #'default-keysym-translate
  160.   ;;
  161.   (declare (type (or string-char t) object)
  162.        (type keysym keysym)
  163.        (type (or null mask16 list) ;; (list (or keysym state-mask-key))
  164.              modifiers)
  165.        (type (or null (member :modifiers) mask16 list) ;; (list (or keysym state-mask-key))
  166.              mask)
  167.        (type (or null display) display)
  168.            (type (or null keysym) lowercase)
  169.        (type (function (display card16 t) t) translate))
  170.   (flet ((merge-keysym-mappings (new old)
  171.        ;; Merge new keysym-mapping with list of old mappings.
  172.        ;; Ensure that the mapping with no modifiers or mask comes first.
  173.        (let* ((key (keysym-mapping-modifiers new))
  174.           (merge (delete key old :key #'cadddr :test #'equal)))
  175.          (if key
  176.          (nconc merge (list new))
  177.            (cons new merge))))
  178.      (mask-check (mask)
  179.        (unless (or (numberp mask)
  180.                (dolist (element mask t)
  181.              (unless (or (find element *state-mask-vector*)
  182.                      (gethash element *keysym->character-map*))
  183.                (return nil))))
  184.          (x-type-error mask '(or mask16 (list (or modifier-key modifier-keysym)))))))
  185.     (let ((entry
  186.         ;; Create with a single LIST call, to ensure cdr-coding
  187.         (cond
  188.           (mask
  189.            (unless (eq mask :modifiers)
  190.          (mask-check mask))
  191.            (when (or (null modifiers) (and (numberp modifiers) (zerop modifiers)))
  192.          (error "Mask with no modifiers"))
  193.            (list object translate lowercase modifiers mask))
  194.           (modifiers (mask-check modifiers)
  195.              (list object translate lowercase modifiers))
  196.           (lowercase    (list object translate lowercase))
  197.           (translate    (list object translate))
  198.           (t    (list object)))))
  199.       (if display
  200.       (let ((previous (assoc keysym (display-keysym-translation display))))
  201.         (if previous
  202.         (setf (cdr previous) (merge-keysym-mappings entry (cdr previous)))
  203.           (push (list keysym entry) (display-keysym-translation display))))
  204.     (setf (gethash keysym *keysym->character-map*)
  205.           (merge-keysym-mappings entry (gethash keysym *keysym->character-map*)))))
  206.     object))
  207.  
  208. (defun undefine-keysym (object keysym &key display modifiers &allow-other-keys)                  
  209.   ;; Undefine the keysym-translation translating KEYSYM to OBJECT with MODIFIERS.
  210.   ;; If DISPLAY is non-nil, undefine the translation for DISPLAY if it exists.
  211.   (declare (type (or string-char t) object)
  212.        (type keysym keysym)
  213.        (type (or null mask16 list) ;; (list (or keysym state-mask-key))
  214.              modifiers)
  215.        (type (or null display) display))
  216.   (flet ((match (key entry)
  217.        (let ((object (car key))
  218.          (modifiers (cdr key)))
  219.          (or (eql object (keysym-mapping-object entry))
  220.          (equal modifiers (keysym-mapping-modifiers entry))))))
  221.     (let* (entry
  222.        (previous (if display
  223.              (cdr (setq entry (assoc keysym (display-keysym-translation display))))
  224.                (gethash keysym *keysym->character-map*)))
  225.        (key (cons object modifiers)))
  226.       (when (and previous (find key previous :test #'match))
  227.     (setq previous (delete key previous :test #'match))
  228.     (if display
  229.         (setf (cdr entry) previous)
  230.       (setf (gethash keysym *keysym->character-map*) previous))))))
  231.  
  232. (defun keysym-downcase (keysym)
  233.   ;; If keysym has a lower-case equivalent, return it, otherwise return keysym.
  234.   (declare (type keysym keysym))
  235.   (declare-values keysym)
  236.   (let ((translations (gethash keysym *keysym->character-map*)))
  237.     (or (and translations (keysym-mapping-lowercase (first translations))) keysym)))
  238.  
  239. (defun keysym-uppercase-alphabetic-p (keysym)
  240.   ;; Returns T if keysym is uppercase-alphabetic.
  241.   ;; I.E. If it has a lowercase equivalent.
  242.   (declare (type keysym keysym))
  243.   (declare-values (or null keysym))
  244.   (let ((translations (gethash keysym *keysym->character-map*)))
  245.     (and translations
  246.      (keysym-mapping-lowercase (first translations)))))
  247.  
  248. (defun character->keysyms (character &optional display)
  249.   ;; Given a character, return a list of all matching keysyms.
  250.   ;; If DISPLAY is given, translations specific to DISPLAY are used,
  251.   ;; otherwise only global translations are used.
  252.   ;; Implementation dependent function.
  253.   ;; May be slow [i.e. do a linear search over all known keysyms]
  254.   (declare (type t character)
  255.        (type (or null display) display)
  256.        (values (list keysym)))
  257.   (let ((result nil))
  258.     (when display
  259.       (dolist (mapping (display-keysym-translation display))
  260.     (when (eql character (second mapping))
  261.       (push (first mapping) result))))
  262.     (maphash #'(lambda (keysym mappings)
  263.          (dolist (mapping mappings)
  264.            (when (eql (keysym-mapping-object mapping) character)
  265.              (pushnew keysym result))))
  266.          *keysym->character-map*)
  267.     result))
  268.  
  269. (eval-when (compile eval load) ;; Required for Symbolics...
  270. (defconstant character-set-switch-keysym (keysym 255 126))
  271. (defconstant left-shift-keysym (keysym 255 225))
  272. (defconstant right-shift-keysym (keysym 255 226))
  273. (defconstant left-control-keysym (keysym 255 227))
  274. (defconstant right-control-keysym (keysym 255 228))
  275. (defconstant caps-lock-keysym (keysym 255 229))
  276. (defconstant shift-lock-keysym (keysym 255 230))
  277. (defconstant left-meta-keysym (keysym 255 231))
  278. (defconstant right-meta-keysym (keysym 255 232))
  279. (defconstant left-alt-keysym (keysym 255 233))
  280. (defconstant right-alt-keysym (keysym 255 234))
  281. (defconstant left-super-keysym (keysym 255 235))
  282. (defconstant right-super-keysym (keysym 255 236))
  283. (defconstant left-hyper-keysym (keysym 255 237))
  284. (defconstant right-hyper-keysym (keysym 255 238))
  285. ) ;; end eval-when
  286.  
  287.  
  288. ;;-----------------------------------------------------------------------------
  289. ;; Keysym mapping functions
  290.  
  291. (defun display-keyboard-mapping (display)
  292.   (declare (type display display))
  293.   (declare-values (simple-array keysym (display-max-keycode keysyms-per-keycode)))
  294.   (or (display-keysym-mapping display)
  295.       (setf (display-keysym-mapping display) (xlib:keyboard-mapping display))))
  296.  
  297. (defun keycode->keysym (display keycode keysym-index)
  298.   (declare (type display display)
  299.        (type card8 keycode)
  300.        (type (or null card8) keysym-index)
  301.        (values keysym))
  302.   (let* ((mapping (display-keyboard-mapping display))
  303.      (keysym (aref mapping keycode keysym-index)))
  304.     (declare (type (simple-array keysym (* *)) mapping)
  305.          (type keysym keysym))
  306.     ;; The keysym-mapping is brain dammaged.
  307.     ;; Mappings for both-case alphabetic characters have the
  308.     ;; entry for keysym-index zero set to the uppercase keysym
  309.     ;; (this is normally where the lowercase keysym goes), and the
  310.     ;; entry for keysym-index one is zero.
  311.     (cond ((zerop keysym-index)            ; Lowercase alphabetic keysyms
  312.        (keysym-downcase keysym))
  313.       ((and (zerop keysym) (plusp keysym-index)) ; Get the uppercase keysym
  314.        (aref mapping keycode 0))
  315.       (t keysym))))
  316.  
  317. (defun keysym->character (display keysym &optional (state 0))
  318.   ;; Find the character associated with a keysym.
  319.   ;; STATE is used for adding char-bits to character as follows:
  320.   ;;    control -> char-control-bit
  321.   ;;    mod-1 -> char-meta-bit
  322.   ;;    mod-2 -> char-super-bit
  323.   ;;    mod-3 -> char-hyper-bit
  324.   ;; Implementation dependent function.
  325.   (declare (type display display)
  326.        (type keysym keysym)
  327.        (type card16 state))
  328.   (declare-values (or null character))
  329.   (let* ((display-mappings (cdr (assoc keysym (display-keysym-translation display))))
  330.      static-mappings
  331.      (mapping (or ;; Find the matching display mapping
  332.               (dolist (mapping display-mappings)
  333.             (when (mapping-matches-p display state mapping)
  334.               (return mapping)))
  335.               ;; Find the matching static mapping
  336.               (dolist (mapping (setq static-mappings (gethash keysym *keysym->character-map*)))
  337.             (when (mapping-matches-p display state mapping)
  338.               (return mapping))))))
  339.     (when mapping
  340.       (funcall (or (keysym-mapping-translate mapping) 'default-keysym-translate)
  341.            display state (keysym-mapping-object mapping)))))
  342.  
  343. (defun mapping-matches-p (display state mapping)
  344.   ;; Returns T when the modifiers and mask in MAPPING satisfies STATE for DISPLAY
  345.   (declare (type display display)
  346.        (type mask16 state)
  347.        (type list mapping))
  348.   (declare-values boolean)
  349.   (flet
  350.     ((modifiers->mask (display-mapping modifiers errorp &aux (mask 0))
  351.        ;; Convert MODIFIERS, which is a modifier mask, or a list of state-mask-keys into a mask.
  352.        ;; If ERRORP is non-nil, return NIL when an unknown modifier is specified,
  353.        ;; otherwise ignore unknown modifiers.
  354.        (declare (type list display-mapping)    ; Alist of (keysym . mask)
  355.         (type (or mask16 list) modifiers)
  356.         (type mask16 mask))
  357.        (declare-values (or null mask16))
  358.        (if (numberp modifiers)
  359.        modifiers
  360.      (dolist (modifier modifiers mask)
  361.        (declare (type symbol modifier))
  362.        (let ((bit (position modifier (the simple-vector *state-mask-vector*) :test #'eq)))
  363.          (setq mask
  364.            (logior mask
  365.                (if bit
  366.                    (ash 1 bit)
  367.                  (or (cdr (assoc modifier display-mapping))
  368.                  ;; bad modifier
  369.                  (if errorp
  370.                      (return-from modifiers->mask nil)
  371.                    0))))))))))
  372.  
  373.     (let* ((display-mapping (get-display-modifier-mapping display))
  374.        (mapping-modifiers (keysym-mapping-modifiers mapping))
  375.        (modifiers (or (modifiers->mask display-mapping (or mapping-modifiers 0) t)
  376.               (return-from mapping-matches-p nil)))
  377.        (mapping-mask (or (keysym-mapping-mask mapping)    ; If no mask, use the default.
  378.                  (if mapping-modifiers            ; If no modifiers, match anything.
  379.                  *default-keysym-translate-mask*
  380.                    0)))
  381.        (mask (if (eq mapping-mask :modifiers)
  382.              modifiers
  383.            (modifiers->mask display-mapping mapping-mask nil))))
  384.       (declare (type mask16 modifiers mask))
  385.       (= (logand state mask) modifiers))))
  386.  
  387. (defun default-keysym-translate (display state object)
  388.   ;; If object is a character, char-bits are set from state.
  389.   ;;
  390.   ;; [the following isn't implemented (should it be?)]
  391.   ;; If object is a list, it is an alist with entries:
  392.   ;; (string-char [modifiers] [mask-modifiers])
  393.   ;; When MODIFIERS are specified, this character translation
  394.   ;; will only take effect when the specified modifiers are pressed.
  395.   ;; MASK-MODIFIERS can be used to specify a set of modifiers to ignore.
  396.   ;; When MASK-MODIFIERS is missing, all other modifiers are ignored.
  397.   ;; In ambiguous cases, the most specific translation is used.
  398.   (declare (type display display)
  399.        (type card16 state)
  400.        (type t object))
  401.   (declare-values t) ;; Object returned by keycode->character
  402.   (macrolet ((keystate-p (state keyword)
  403.              `(the boolean
  404.                    (logbitp ,(position keyword *state-mask-vector*)
  405.                     ,state))))
  406.     (when (characterp object)
  407.       (when (keystate-p state :control)
  408.     (setf (char-bit object :control) 1))
  409.       (when (state-keysymp display state left-meta-keysym)
  410.     (setf (char-bit object :meta) 1))
  411.       (when (state-keysymp display state left-super-keysym)
  412.     (setf (char-bit object :super) 1))
  413.       (when (state-keysymp display state left-hyper-keysym)
  414.     (setf (char-bit object :hyper) 1))))
  415.   object)
  416.  
  417. (defun default-keysym-index (display keycode state)
  418.   ;; Returns a keysym-index for use with keycode->character
  419.   (declare-values card8)
  420.   (macrolet ((keystate-p (state keyword)
  421.            `(the boolean
  422.              (logbitp ,(position keyword *state-mask-vector*)
  423.                   ,state))))
  424.     (let* ((mapping (display-keyboard-mapping display))
  425.        (keysyms-per-keycode (array-dimension mapping 1))
  426.        (symbolp (and (> keysyms-per-keycode 2)
  427.              (state-keysymp display state character-set-switch-keysym)))
  428.        (result (if symbolp 2 0)))
  429.       (declare (type (simple-array keysym (* *)) mapping)
  430.            (type boolean symbolp)
  431.            (type card8 keysyms-per-keycode result))
  432.       (when (and (< result keysyms-per-keycode)
  433.          (keysym-shift-p display state (keysym-uppercase-alphabetic-p
  434.                          (aref mapping keycode 0))))
  435.     (incf result))
  436.       result)))
  437.  
  438. (defun keysym-shift-p (display state uppercase-alphabetic-p &key
  439.                shift-lock-xors
  440.                (control-modifiers
  441.              '#.(list left-meta-keysym left-super-keysym left-hyper-keysym)))
  442.   (declare (type display display)
  443.        (type card16 state)
  444.        (type boolean uppercase-alphabetic-p)
  445.        (type boolean shift-lock-xors));;; If T, both SHIFT-LOCK and SHIFT is the same
  446.                                       ;;; as neither if the character is alphabetic.
  447.   (declare-values boolean)
  448.   (macrolet ((keystate-p (state keyword)
  449.            `(the boolean
  450.              (logbitp ,(position keyword *state-mask-vector*)
  451.                   ,state))))
  452.     (let* ((controlp (or (keystate-p state :control)
  453.              (dolist (modifier control-modifiers)
  454.                (when (state-keysymp display state modifier)
  455.                  (return t)))))
  456.        (shiftp (keystate-p state :shift))
  457.        (lockp  (keystate-p state :lock))
  458.        (alphap (or uppercase-alphabetic-p
  459.                (not (state-keysymp display #.(make-state-mask :lock)
  460.                        caps-lock-keysym)))))
  461.       (declare (type boolean controlp shiftp lockp alphap))
  462.       ;; Control keys aren't affected by lock
  463.       (if controlp
  464.       ;; An alphabetic control character defaults to uppercase
  465.       (when alphap (setq shiftp (not shiftp)))
  466.     ;; Not a control character - check state of lock modifier
  467.     (when (and lockp
  468.            alphap
  469.            (or (not shiftp) shift-lock-xors))    ; Lock doesn't unshift unless shift-lock-xors
  470.       (setq shiftp (not shiftp))))
  471.       shiftp)))
  472.  
  473. ;;; default-keysym-index implements the following tables:
  474. ;;;
  475. ;;; control shift caps-lock character               character
  476. ;;;   0       0       0       #\a                      #\8
  477. ;;;   0       0       1       #\A                      #\8
  478. ;;;   0       1       0       #\A                      #\*
  479. ;;;   0       1       1       #\A                      #\*
  480. ;;;   1       0       0       #\control-A              #\control-8
  481. ;;;   1       0       1       #\control-A              #\control-8
  482. ;;;   1       1       0       #\control-shift-a        #\control-*
  483. ;;;   1       1       1       #\control-shift-a        #\control-*
  484. ;;;
  485. ;;; control shift shift-lock character               character
  486. ;;;   0       0       0       #\a                      #\8
  487. ;;;   0       0       1       #\A                      #\*
  488. ;;;   0       1       0       #\A                      #\*
  489. ;;;   0       1       1       #\A                      #\8
  490. ;;;   1       0       0       #\control-A              #\control-8
  491. ;;;   1       0       1       #\control-A              #\control-*
  492. ;;;   1       1       0       #\control-shift-a        #\control-*
  493. ;;;   1       1       1       #\control-shift-a        #\control-8
  494.  
  495. (defun keycode->character (display keycode state &key keysym-index
  496.                        (keysym-index-function #'default-keysym-index))
  497.   ;; keysym-index defaults to the result of keysym-index-function which
  498.   ;; is called with the following parameters:
  499.   ;; (char0 state caps-lock-p keysyms-per-keycode)
  500.   ;; where char0 is the "character" object associated with keysym-index 0 and
  501.   ;; caps-lock-p is non-nil when the keysym associated with the lock
  502.   ;; modifier is for caps-lock.
  503.   ;; STATE is also used for setting char-bits:
  504.   ;;    control -> char-control-bit
  505.   ;;    mod-1 -> char-meta-bit
  506.   ;;    mod-2 -> char-super-bit
  507.   ;;    mod-3 -> char-hyper-bit
  508.   ;; Implementation dependent function.
  509.   (declare (type display display)
  510.        (type card8 code)
  511.        (type card16 state)
  512.        (type (or null card8) keysym-index)
  513.        (type (or null (function (string-char card16 boolean card8) card8))
  514.          keysym-index-function))
  515.   (declare-values (or null character))
  516.   (let* ((index (or keysym-index
  517.             (funcall keysym-index-function display keycode state)))
  518.      (keysym (if index (keycode->keysym display keycode index) 0)))
  519.     (declare (type (or null card8) index)
  520.          (type keysym keysym))
  521.     (when (plusp keysym)
  522.       (keysym->character display keysym state))))
  523.  
  524. (defun get-display-modifier-mapping (display)
  525.   (labels ((keysym-replace (display modifiers mask &aux result)
  526.          (dolist (modifier modifiers result)
  527.            (push (cons (keycode->keysym display modifier 0) mask) result))))
  528.     (or (display-modifier-mapping display)
  529.     (multiple-value-bind (shift lock control mod1 mod2 mod3 mod4 mod5)
  530.         (modifier-mapping display)
  531.       (setf (display-modifier-mapping display)
  532.         (nconc (keysym-replace display shift #.(make-state-mask :shift))
  533.                (keysym-replace display lock #.(make-state-mask :lock))
  534.                (keysym-replace display control #.(make-state-mask :control))
  535.                (keysym-replace display mod1 #.(make-state-mask :mod-1))
  536.                (keysym-replace display mod2 #.(make-state-mask :mod-2))
  537.                (keysym-replace display mod3 #.(make-state-mask :mod-3))
  538.                (keysym-replace display mod4 #.(make-state-mask :mod-4))
  539.                (keysym-replace display mod5 #.(make-state-mask :mod-5))))))))
  540.  
  541. (defun state-keysymp (display state keysym)
  542.   ;; Returns T when a modifier key associated with KEYSYM is on in STATE
  543.   (declare (type display display)
  544.        (type card16 state)
  545.        (type keysym keysym))
  546.   (declare-values boolean)
  547.   (let* ((mapping (get-display-modifier-mapping display))
  548.      (mask (assoc keysym mapping)))
  549.     (and mask (plusp (logand state (cdr mask))))))
  550.  
  551. (defun mapping-notify (display request start count)
  552.   ;; Called on a mapping-notify event to update
  553.   ;; the keyboard-mapping cache in DISPLAY
  554.   (declare (type display display)
  555.        (type (member :modifier :keyboard :pointer) request)
  556.        (type card8 start count)
  557.        (ignore count start))
  558.   ;; Invalidate the keyboard mapping to force the next key translation to get it
  559.   (case request
  560.     (:modifier 
  561.      (setf (display-modifier-mapping display) nil))
  562.     (:keyboard
  563.      (setf (display-keysym-mapping display) nil))))
  564.  
  565. (defun keysym-in-map-p (display keysym keymap)
  566.   ;; Returns T if keysym is found in keymap
  567.   (declare (type display display)
  568.        (type keysym keysym)
  569.        (type (bit-vector 256) keymap))
  570.   (declare-values boolean)
  571.   ;; The keysym may appear in the keymap more than once,
  572.   ;; So we have to search the entire keysym map.
  573.   (do* ((min (display-min-keycode display))
  574.     (max (display-max-keycode display))
  575.     (map (display-keyboard-mapping display))
  576.     (jmax (min 2 (array-dimension map 1)))
  577.     (i min (1+ i)))
  578.       ((> i max))
  579.     (declare (type card8 min max jmax)
  580.          (type (simple-array keysym (* *)) map))
  581.     (when (and (plusp (aref keymap i))
  582.            (dotimes (j jmax)
  583.          (when (= keysym (aref map i j)) (return t))))
  584.       (return t))))
  585.  
  586. (defun character-in-map-p (display character keymap)
  587.   ;; Implementation dependent function.
  588.   ;; Returns T if character is found in keymap
  589.   (declare (type display display)
  590.        (type character character)
  591.        (type (bit-vector 256) keymap))
  592.   (declare-values boolean)
  593.   ;; Check all one bits in keymap
  594.   (do* ((min (display-min-keycode display))
  595.     (max (display-max-keycode display))
  596.     (jmax (array-dimension (display-keyboard-mapping display) 1))
  597.     (i min (1+ i)))
  598.       ((> i max))
  599.     (declare (type card8 min max jmax))
  600.     (when (and (plusp (aref keymap i))
  601.            ;; Match when character is in mapping for this keycode
  602.            (dotimes (j jmax)
  603.          (when (eql character (keycode->character display i 0 :keysym-index j))
  604.            (return t))))
  605.       (return t))))
  606.  
  607. (defun keysym->keycodes (display keysym)
  608.   ;; Return keycodes for keysym, as multiple values
  609.   (declare (type display display)
  610.        (type keysym keysym))
  611.   (declare-values (or null keycode) (or null keycode) (or null keycode))
  612.   ;; The keysym may appear in the keymap more than once,
  613.   ;; So we have to search the entire keysym map.
  614.   (do* ((min (display-min-keycode display))
  615.     (max (display-max-keycode display))
  616.     (map (display-keyboard-mapping display))
  617.     (jmax (min 2 (array-dimension map 1)))
  618.     (i min (1+ i))
  619.     (result nil))
  620.       ((> i max) (values-list result))
  621.     (declare (type card8 min max jmax)
  622.          (type (simple-array keysym (* *)) map))
  623.     (dotimes (j jmax)
  624.       (when (= keysym (aref map i j))
  625.     (push i result)))))
  626.